
module GeneratrixRender where
import PHaskellParser 
import PHaskellTypes
import TemplatesTypes
import TemplateRender
import LambdaTypes
import Fase1
import TranslateLambdaToTemplate
import Char



--data Generatrix = Generatrix  [String] String [Exp] [CArg] CExp -- return type, funcion name,  argument list, Cargs, Codegenerator
					--deriving (Eq,Show) 


type GeneratrixSame = (String , [Generatrix]) --Set of generatrix called equal


insertNewGeneratix::Generatrix->[GeneratrixSame]->[GeneratrixSame]
insertNewGeneratix g@(Generatrix  _ name _ _ _) [] = [(name, [g])] 
insertNewGeneratix g@(Generatrix  _ name _ _ _) ((name2, gs):xs) | name == name2 = (name, g:gs):xs
																 | otherwise     = (name2, gs):(insertNewGeneratix g xs)

--Agrupa todas las generatrices con el mismo nombre
buildGeneratrixSames' (x:xs) gs = buildGeneratrixSames' xs (insertNewGeneratix x gs)
buildGeneratrixSames'  ([]) gs  = gs

buildGeneratrixSames xs = buildGeneratrixSames' xs []



-- El contexto consta de la lista de los padres de donde provino la 
-- expresion, la lista de variables bindeadas, nombres que son constructores
--type Context = ([Parent],[String], [String])

 
renderGeneratrixWithInitialContext::GeneratrixProgram->[TypeDefinition]->Context->LUserDefinedTypes->String
renderGeneratrixWithInitialContext generatrixProgram td cs tn = concat (map (renderGeneratrixSame  td cs tn 0) generatrixes)  
															where
																generatrixes = buildGeneratrixSames generatrixProgram
																


--Generatrix  [String] String [Exp] [CArg] CExp
renderGeneratrixSame::[TypeDefinition]->Context->LUserDefinedTypes->Int->GeneratrixSame->String
renderGeneratrixSame  td cs tn n  (name, gs) =  "struct "++name++"\n"
										++ (spaces n) ++ "{\n" 
											++ concat (map (renderGeneratrixOperator  td cs tn (n+2)) gs)
										++ (spaces n) ++ "};\n"
										
renderGeneratrixOperator::[TypeDefinition]->Context->LUserDefinedTypes->Int->Generatrix->String
renderGeneratrixOperator  td cs tn n  (Generatrix returnType name args cargs codeExp) = ""
										++ (spaces n) ++ "template"++ (buildTemplateHeaderList td cs' tn args) 
										++ (spaces n) ++ "struct generatrix"++   (buildTemplateSpecializationList td cs' tn args) 
										++ (spaces n) ++ "{\n"
                                        ++ (spaces (n+2)) ++"static "++ (renderType returnType)++"code("++ renderCargs cargs++")\n"
										++ (spaces (n+2)) ++ "{\n"
										++ (spaces (n+4))   ++ "return "++(renderCodeExp td cs' tn codeExp)++";\n"
										++ (spaces (n+2)) ++ "}\n"
										++ (spaces n) ++ "};\n\n"
											where
												 variableList = concat (map getVariableListFromMetaExp metaExpList)
												 metaExpList  = map (getMetaExp td cs tn) args
												 cs'          = addParent PMetaLambda (addListBinded variableList cs) --lo hacemos metalambda para que tenga el entorno de un template
												 
											
										


renderType (x:xs) = x++" "++(renderType xs)																																	
renderType   []   = ""


renderCargs::[CArg]->String
renderCargs   []   = ""
renderCargs (x:[]) = renderCarg x
renderCargs (x:xs) = (renderCarg x)++ ", "++(renderCargs xs)
						
renderCarg (CArg types varName)= (renderType types)++" "++varName
renderCarg _ = "Invalid C Argument"


renderStringList::[String]->String
renderStringList   []   = ""
renderStringList (x:[]) = x
renderStringList (x:xs) = x++ ", "++(renderStringList xs)

renderClassStringList::[String]->String
renderClassStringList   []   = ""
renderClassStringList (x:[]) = "class "++x
renderClassStringList (x:xs) = ("class "++x )++ ", "++(renderClassStringList xs)
 
-- ------------------------ TEMPLATE LIST and SPECIALIZATION ---------------------------  
buildTemplateHeaderList::[TypeDefinition]->Context->LUserDefinedTypes->[Exp]->String
buildTemplateHeaderList td cs tn es   =   case allVariables metaExpList of
													False ->"<"++ (renderClassStringList ((concat (map getVariableListFromMetaExp metaExpList))++["__d3245"])) ++" >\n"
													True  ->"<"++ (renderClassStringList ((concat (map getVariableListFromMetaExp metaExpList))++["__d3245=void"])) ++" >\n"
												where
													metaExpList     = map (getMetaExp td cs tn) es
													allVariables [] = True 
													allVariables ((MetaVariable _):xs) = allVariables xs
													allVariables (x:xs) = False
										

buildTemplateSpecializationList::[TypeDefinition]->Context->LUserDefinedTypes->[Exp]->String
buildTemplateSpecializationList td cs tn es   = case allVariables metaExpList of
													True ->"\n"
													False->"< "++ (renderStringList ((map (renderHaskellExpSpecialization td cs tn) es)++["__d3245"]))++" >\n"
													where
														metaExpList     = map (getMetaExp td cs tn) es
														allVariables [] = True 
														allVariables ((MetaVariable _):xs) = allVariables xs
														allVariables (x:xs) = False
												
											


--getVariableListFromMetaExp (MetaExp)
--returns a list of variables in the exp
getVariableListFromMetaExp::MetaExp->[String] 
getVariableListFromMetaExp (MetaVariable var) = [var] 
getVariableListFromMetaExp (MetaTypeConstructor t es) = concat (map getVariableListFromMetaExp es)
getVariableListFromMetaExp (MetaApp    e1 e2)         = (getVariableListFromMetaExp e1) ++ (getVariableListFromMetaExp e2)
getVariableListFromMetaExp (MetaIf     e1 e2 e3)      = (getVariableListFromMetaExp e1) ++ (getVariableListFromMetaExp e2) ++ (getVariableListFromMetaExp e3)  
getVariableListFromMetaExp (MetaIfOnly e1 e2)         = (getVariableListFromMetaExp e1) ++ (getVariableListFromMetaExp e2)
getVariableListFromMetaExp  e = []


-- -------------------------------------------------------------------------------------
 
              		
--renderMetaExp::Context->Int->MetaExp->String
--buildLExpresion::[TypeDefinition]->Exp->LExp
renderCodeExp::[TypeDefinition]->Context->LUserDefinedTypes->CExp->String
renderCodeExp td cs tn (CodeParent e) = "("++ (renderCodeExp td cs tn e) ++")"
renderCodeExp td cs tn (CodeVariable varname) = varname
renderCodeExp td cs tn (CodeNumber   number)  = number
renderCodeExp td cs tn (CodeBoolean  boolean) = boolean
renderCodeExp td cs tn (CodeBinaryNotEq e1 e2) = (renderCodeExp td cs tn e1)++"!="++(renderCodeExp td cs tn  e2)
renderCodeExp td cs tn (CodeBinaryEq e1 e2) =(renderCodeExp td cs tn e1)++"=="++(renderCodeExp td cs tn  e2)
renderCodeExp td cs tn (CodeBinaryOpShiftLeft e1 e2) =(renderCodeExp td cs tn e1)++"<<"++(renderCodeExp td cs tn  e2)
renderCodeExp td cs tn (CodeBinaryOpShiftRight e1 e2) =(renderCodeExp td cs tn e1)++">>"++(renderCodeExp td cs tn  e2)
renderCodeExp td cs tn (CodeBinaryOpMult e1 e2) = (renderCodeExp td cs tn e1)++"*"++(renderCodeExp td cs tn  e2)
renderCodeExp td cs tn (CodeBinaryOpDiv e1 e2)  = (renderCodeExp td  cs tn e1)++"/"++(renderCodeExp td  cs tn e2)
renderCodeExp td cs tn (CodeBinaryOpAdd e1 e2)  =(renderCodeExp td  cs tn e1)++"+"++(renderCodeExp td  cs tn e2)
renderCodeExp td cs tn (CodeBinaryOpMinus e1 e2)=(renderCodeExp td  cs tn e1)++"-"++(renderCodeExp td  cs tn e2)
renderCodeExp td cs tn (CodeBinaryOpLogicAnd e1 e2)=(renderCodeExp td  cs tn e1)++"&"++(renderCodeExp td  cs tn e2)
renderCodeExp td cs tn (CodeBinaryOpLogicOr e1 e2)= (renderCodeExp td  cs tn e1)++"|"++(renderCodeExp td  cs tn e2)
renderCodeExp td cs tn (CodeBinaryOpLogicXor e1 e2)=(renderCodeExp td  cs tn e1)++"^"++(renderCodeExp td  cs tn e2)
renderCodeExp td cs tn (CodeBinaryAssign e1 e2)= (renderCodeExp td  cs tn e1)++"="++(renderCodeExp td  cs tn e2) 
renderCodeExp td cs tn (CodeStaticAccess  e1 e2)= (renderCodeExp td  cs tn e1)++"::"++(renderCodeExp td  cs tn e2) 
renderCodeExp td cs tn (CodeClassAccess   e1 e2)= (renderCodeExp td  cs tn e1)++"."++(renderCodeExp td  cs tn e2)
renderCodeExp td cs tn (CodeArraySubscript  e1 e2)= (renderCodeExp td  cs tn e1)++"["++(renderCodeExp td  cs tn e2)++"]"
renderCodeExp td cs tn (CodeIf e1 e2 e3)        = (renderCodeExp td  cs tn e1)++"?"++(renderCodeExp td  cs tn e2) ++":"++(renderCodeExp td cs tn e3)
renderCodeExp td cs tn (CodeFunctionCall  e1 args) =(renderCodeExp td  cs tn e1)++"("++(renderCExpList td cs tn args)++")"
renderCodeExp td cs tn (CodeTemplateInst e1 args)  =(renderCodeExp td  cs tn e1)++"<"++(renderCExpList td cs tn args)++" >"
renderCodeExp td cs tn (CodeSequense e1 e2)  =(renderCodeExp td  cs tn e1)++", "++(renderCodeExp td  cs tn e2) 
renderCodeExp td cs tn (CodePHaskellExp  haskellExp) ="("++ renderHaskellExp td  cs tn haskellExp ++")"
renderCodeExp td cs tn (CodeGeneratrixCall name hes args) = "("++ name ++"::generatrix<"++ (renderStringList (map (renderHaskellExp td  cs tn) hes)) ++" >::code("++  (renderCExpList td cs tn args) ++")" 	++")"													
renderCodeExp td cs tn (CodeString str) = "\""++str++"\"" 
renderCodeExp td cs tn (CodeUnaryLNot e1) = "~"++(renderCodeExp td  cs tn e1)
--renderCodeExp td cs tn codeExp = error (show codeExp)

--render haskell exps
--Translate from Exp to  MetaExp
getMetaExp::[TypeDefinition]->Context->LUserDefinedTypes->Exp->MetaExp
getMetaExp td cs tn e = translateEval (lambdaUserDefinedTypedExp tn (buildLExpresion td e))

renderHaskellExp::[TypeDefinition]->Context->LUserDefinedTypes->Exp->String
renderHaskellExp td cs tn e  = "typename "++(renderMetaExp  cs  0 (getMetaExp td cs tn e ))++ "::value" --es siempre eager

												
renderHaskellExpSpecialization::[TypeDefinition]->Context->LUserDefinedTypes->Exp->String
renderHaskellExpSpecialization td cs tn e  = (renderMetaExp  cs 0 metaExp  ) --es siempre eager
												where
												 --variableList = getVariableListFromMetaExp metaExp
												 --cs'          = addListBinded variableList cs
												 metaExp      = (getMetaExp td cs tn e )

													


renderCExpList::[TypeDefinition]->Context->LUserDefinedTypes->[CExp]->String
renderCExpList td cs tn []   = ""
renderCExpList td cs tn (x:[]) = renderCodeExp td cs tn x
renderCExpList td cs tn (x:xs) = (renderCodeExp td cs tn x)++ ", "++(renderCExpList td cs tn xs)



generatrixRender::String->String
generatrixRender strProgram = renderGeneratrixWithInitialContext generatrixDef typeDefinition  initialContext typesDefinitionNames 
									 where
									 	haskellProgram    = (parser.lexer) (strProgram)
										generatrixDef         = map unTuneling (filter isGeneratrixTunneling haskellProgram)
																	where
																		unTuneling (GeneratrixTunneling g) = g	
										typeDefinition        = builtInitialHaskellContext haskellProgram
										typesDefinitionNames  = buildUserDefinedTypesConstructors haskellProgram
										initialContext        = buildTemplateInitialContext typesDefinitionNames
															
										


